home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmpmap.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  9KB  |  238 lines
  1. ;;; CMPMAP  Map functions.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'mapcar 'c1mapcar 'c1)
  10. (si:putprop 'maplist 'c1maplist 'c1)
  11. (si:putprop 'mapcar 'c2mapcar 'c2)
  12. (si:putprop 'mapc 'c1mapc 'c1)
  13. (si:putprop 'mapl 'c1mapl 'c1)
  14. (si:putprop 'mapc 'c2mapc 'c2)
  15. (si:putprop 'mapcan 'c1mapcan 'c1)
  16. (si:putprop 'mapcon 'c1mapcon 'c1)
  17. (si:putprop 'mapcan 'c2mapcan 'c2)
  18.  
  19. (defun c1mapcar (args) (c1map-functions 'mapcar t args))
  20. (defun c1maplist (args) (c1map-functions 'mapcar nil args))
  21. (defun c1mapc (args) (c1map-functions 'mapc t args))
  22. (defun c1mapl (args) (c1map-functions 'mapc nil args))
  23. (defun c1mapcan (args) (c1map-functions 'mapcan t args))
  24. (defun c1mapcon (args) (c1map-functions 'mapcan nil args))
  25.  
  26. (defun c1map-functions (name car-p args &aux funob info)
  27.   (when (or (endp args) (endp (cdr args)))
  28.         (too-few-args 'map-function 2 (length args)))
  29.   (setq funob (c1funob (car args)))
  30.   (setq info (copy-info (cadr funob)))
  31.   (list name info funob car-p (c1args (cdr args) info))
  32.   )
  33.  
  34. (defun c2mapcar (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0))
  35.   (let ((label (next-label*))
  36.         (value-loc (list 'VS (vs-push)))
  37.         (handy (list 'CVAR (next-cvar)))
  38.         (handies (mapcar #'(lambda (x) (declare (ignore x))
  39.                                    (list 'CVAR (next-cvar)))
  40.                          args))
  41.         save
  42.         )
  43.        (setq save (save-funob funob))
  44. ;       (setq args (inline-args args
  45. ;                               (make-list (length args) :initial-element t)))
  46.        (setq args (push-changed-vars
  47.                    (inline-args args (make-list (length args)
  48.                                                 :initial-element t))
  49.                    funob))
  50.        (wt-nl "{object " handy ";")
  51.        (dolist** (loc handies)
  52.          (wt-nl "object " loc "= " (car args) ";")
  53.          (pop args))
  54.        (cond (*safe-compile*
  55.               (wt-nl "if(endp(" (car handies) ")")
  56.               (dolist** (loc (cdr handies)) (wt "||endp(" loc ")"))
  57.               (wt "){"))
  58.              (t
  59.               (wt-nl "if(" (car handies) "==Cnil")
  60.               (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil"))
  61.               (wt "){")))
  62.        (unwind-exit nil 'jump)
  63.        (wt "}")
  64.        (wt-nl value-loc "=" handy "=MMcons(Cnil,Cnil);")
  65.        (wt-label label)
  66.        (let* ((*value-to-go* (list 'CAR (cadr handy)))
  67.               (*exit* (next-label))
  68.               (*unwind-exit* (cons *exit* *unwind-exit*)))
  69.              (c2funcall funob
  70.                (if car-p
  71.                    (mapcar
  72.                     #'(lambda (loc)
  73.                               (list 'LOCATION *info* (list 'CAR (cadr loc))))
  74.                     handies)
  75.                    (mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
  76.                            handies))
  77.                save)
  78.              (wt-label *exit*))
  79.        (cond (*safe-compile*
  80.               (wt-nl "if(endp(" (car handies) "=MMcdr(" (car handies) "))")
  81.               (dolist** (loc (cdr handies))
  82.                         (wt "||endp(" loc "=MMcdr(" loc "))"))
  83.               (wt "){"))
  84.              (t
  85.               (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil")
  86.               (dolist** (loc (cdr handies))
  87.                         (wt "||(" loc "=MMcdr(" loc "))==Cnil"))
  88.               (wt "){")))
  89.        (unwind-exit value-loc 'jump)
  90.        (wt "}")
  91.        (wt-nl handy "=MMcdr(" handy ")=MMcons(Cnil,Cnil);")
  92.        (wt-nl) (wt-go label)
  93.        (wt "}")
  94.        (close-inline-blocks)
  95.        )
  96.   )
  97.  
  98. (defun c2mapc (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0))
  99.   (let ((label (next-label*))
  100.         value-loc
  101.         (handies (mapcar #'(lambda (x) (declare (ignore x))
  102.                                    (list 'CVAR (next-cvar)))
  103.                          args))
  104.         save
  105.         )
  106.        (setq save (save-funob funob))
  107. ;       (setq args (inline-args args
  108. ;                               (make-list (length args) :initial-element t)))
  109.        (setq args (push-changed-vars
  110.                    (inline-args args (make-list (length args)
  111.                                                 :initial-element t))
  112.                    funob))
  113.        (setq value-loc (car args))
  114.        (wt-nl "{")
  115.        (dolist** (loc handies)
  116.                  (wt-nl "object " loc "= " (car args) ";")
  117.                  (pop args))
  118.        (cond (*safe-compile*
  119.               (wt-nl "if(endp(" (car handies) ")")
  120.               (dolist** (loc (cdr handies)) (wt "||endp(" loc ")"))
  121.               (wt "){"))
  122.              (t
  123.               (wt-nl "if(" (car handies) "==Cnil")
  124.               (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil"))
  125.               (wt "){")))
  126.        (unwind-exit nil 'jump)
  127.        (wt "}")
  128.        (wt-label label)
  129.        (let* ((*value-to-go* 'trash)
  130.               (*exit* (next-label))
  131.               (*unwind-exit* (cons *exit* *unwind-exit*)))
  132.              (c2funcall funob
  133.                (if car-p
  134.                    (mapcar
  135.                     #'(lambda (loc)
  136.                               (list 'LOCATION *info* (list 'CAR (cadr loc))))
  137.                     handies)
  138.                    (mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
  139.                            handies))
  140.                save)
  141.              (wt-label *exit*))
  142.        (cond (*safe-compile*
  143.               (wt-nl "if(endp(" (car handies) "=MMcdr(" (car handies) "))")
  144.               (dolist** (loc (cdr handies))
  145.                         (wt "||endp(" loc "=MMcdr(" loc "))"))
  146.               (wt "){"))
  147.              (t
  148.               (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil")
  149.               (dolist** (loc (cdr handies))
  150.                         (wt "||(" loc "=MMcdr(" loc "))==Cnil"))
  151.               (wt "){")))
  152.        (unwind-exit value-loc 'jump)
  153.        (wt "}")
  154.        (wt-nl) (wt-go label)
  155.        (wt "}")
  156.        (close-inline-blocks)
  157.        )
  158.   )
  159.  
  160. (defun c2mapcan (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0))
  161.   (let ((label (next-label*))
  162.         (value-loc (list 'VS (vs-push)))
  163.         (handy (list 'CVAR (next-cvar)))
  164.         (handies (mapcar #'(lambda (x) (declare (ignore x))
  165.                                    (list 'CVAR (next-cvar)))
  166.                          args))
  167.         save
  168.         )
  169.        (setq save (save-funob funob))
  170. ;       (setq args (inline-args args
  171. ;                               (make-list (length args) :initial-element t)))
  172.        (setq args (push-changed-vars
  173.                    (inline-args args (make-list (length args)
  174.                                                 :initial-element t))
  175.                    funob))
  176.        (wt-nl "{object " handy ";")
  177.        (dolist** (loc handies)
  178.                  (wt-nl "object " loc "= " (car args) ";")
  179.                  (pop args))
  180.        (cond (*safe-compile*
  181.               (wt-nl "if(endp(" (car handies) ")")
  182.               (dolist** (loc (cdr handies)) (wt "||endp(" loc ")"))
  183.               (wt "){"))
  184.              (t
  185.               (wt-nl "if(" (car handies) "==Cnil")
  186.               (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil"))
  187.               (wt "){")))
  188.        (unwind-exit nil 'jump)
  189.        (wt "}")
  190.        (wt-nl value-loc "=" handy "=MMcons(Cnil,Cnil);")
  191.        (wt-label label)
  192.        (let* ((*value-to-go* (list 'cdr (cadr handy)))
  193.               (*exit* (next-label))
  194.               (*unwind-exit* (cons *exit* *unwind-exit*))
  195.               )
  196.              (c2funcall funob
  197.                (if car-p
  198.                    (mapcar
  199.                     #'(lambda (loc)
  200.                               (list 'LOCATION *info* (list 'CAR (cadr loc))))
  201.                     handies)
  202.                    (mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
  203.                            handies))
  204.                save)
  205.              (wt-label *exit*))
  206.        (cond
  207.         (*safe-compile*
  208.          (wt-nl "while(!endp(MMcdr(" handy ")))" handy "=MMcdr(" handy ");")
  209.          (wt-nl "if(endp(" (car handies) "=MMcdr(" (car handies) "))")
  210.          (dolist** (loc (cdr handies)) (wt "||endp(" loc "=MMcdr(" loc "))"))
  211.          (wt "){"))
  212.         (t
  213.          (wt-nl "while(MMcdr(" handy ")!=Cnil)" handy "=MMcdr(" handy ");")
  214.          (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil")
  215.          (dolist** (loc (cdr handies))
  216.                    (wt "||(" loc "=MMcdr(" loc "))==Cnil"))
  217.          (wt "){")))
  218.        (wt-nl value-loc "=" value-loc "->c.c_cdr;")
  219.        (unwind-exit value-loc 'jump)
  220.        (wt "}")
  221.        (wt-nl) (wt-go label)
  222.        (wt "}")
  223.        (close-inline-blocks)
  224.        )
  225.   )
  226.  
  227.  
  228. (defun push-changed-vars (locs funob &aux (locs1 nil) (forms (list funob)))
  229.   (dolist (loc locs (reverse locs1))
  230.           (if (and (consp loc)
  231.                    (eq (car loc) 'VAR)
  232.                    (args-info-changed-vars (cadr loc) forms))
  233.               (let ((temp (list 'VS (vs-push))))
  234.                    (wt-nl temp "= " loc ";")
  235.                    (push temp locs1))
  236.               (push loc locs1))))
  237.  
  238.